{-# LANGUAGE RankNTypes                 #-}
{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  HMinCaml.HMonad
-- Copyright   :  (c) Stephen Tetley 2012
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC (RankNTypes)
--
-- Monad for syntax processing - fresh Int, backtracking via 
-- two-continuations and fatal errors.
-- 
-- Warning - associativity of `mplus` is not what we want!
-- Use @(<<|>)@ instead.
--
--------------------------------------------------------------------------------


module HMinCaml.HMonad 
  (
    HMonad
  , runHMonad
  , evalHMonad

  -- * Right asscociative mplus
  , (<<|>) 

  -- * Errors
  , fatal
  , failure
  , (<?>)

  -- * fresh numbers
  , freshInt
  , gentmp
  , genid

  , threshold

  ) where


import HMinCaml.Id
import qualified HMinCaml.Type as T

import Control.Applicative
import Control.Monad

-- | Result supports recoverable error and fatal error.
--
-- Recoverable error backtracks the state.
-- 
-- State is strict.
--
data Result ans = Fatal String | Fail String | Okay ans State
  deriving (Eq,Ord,Show)


type SK a ans = a -> FK ans -> State -> Result ans
type FK ans   = Result ans


data State = State 
      { st_count                :: !Int
      , st_inline_threshold     :: !Int
      }
  deriving (Eq,Ord,Show)

newtype HMonad a = HMonad { 
    getHMonad :: forall ans. SK a ans -> FK ans -> State -> Result ans }


runHMonad :: Int -> HMonad a -> Either String (a,State)
runHMonad i ma = post $ getHMonad ma sk_zero fk_zero st_zero
  where
    sk_zero = \ans _ st -> Okay ans st
    fk_zero = Fail "_initial failure_"
    st_zero = State { st_count = 1, st_inline_threshold = i }

    post (Fatal s)   = Left s
    post (Fail s)    = Left s
    post (Okay a st) = Right (a,st)

evalHMonad :: Int -> HMonad a -> Either String a
evalHMonad i = fmap fst . runHMonad i


instance Functor HMonad where
  fmap f ma = HMonad $ \sk -> getHMonad ma $ \a -> sk (f a)

instance Applicative HMonad where
  pure a    = HMonad $ \sk -> sk a
  af <*> av = HMonad $ \sk -> getHMonad af $ \f -> getHMonad av $ \a -> sk (f a)

instance Monad HMonad where
  return  = pure
  m >>= k = HMonad $ \sk -> getHMonad m $ \a -> getHMonad (k a) sk


instance MonadPlus HMonad  where
  mzero = HMonad $ \_ fk _ -> fk
  mplus = alt


infixr 3 <<|>
(<<|>) :: MonadPlus m => m a -> m a -> m a
(<<|>) = mplus

-- mplus of MonadPlus, (<|>) of Applicative.
--
-- Now with fatal exceptions
--
alt :: HMonad a -> HMonad a -> HMonad a
alt p1 p2 = HMonad $ \sk fk st -> 
    case fk of
      Fatal s -> Fatal s
      hk      -> getHMonad p1 sk (getHMonad p2 sk hk st) st


fatal :: String -> HMonad a
fatal err_msg = HMonad $ \_ _ _ -> Fatal err_msg


-- | Equivalent to 'mzero' with an error message.
--
failure :: String -> HMonad a
failure err_msg = HMonad $ \_ _ _ -> Fail err_msg

infixr 0 <?>

(<?>) :: HMonad a -> String -> HMonad a
p <?> err_msg = HMonad $ \sk fk ss -> getHMonad p sk (swapMsg fk) ss
  where
    swapMsg (Fail _)    = Fail err_msg 
    swapMsg other       = other


freshInt :: HMonad Int
freshInt = HMonad $ \sk fk st -> let i = st_count st
                                 in sk i fk (st { st_count = i + 1})




gentmp :: T.Type -> HMonad IdS
gentmp ty = maybe fk sk $ idOfType ty
  where
    fk    = fatal $ "gentmp - cannot create an identifier for " 
                     ++ show (T.ppType ty) 
    sk ss = (\i -> 'T': ss ++ show i) <$> freshInt

genid :: IdS -> HMonad IdS
genid ss = (\i -> ss ++ '.' : show i) <$> freshInt

threshold :: HMonad Int
threshold = HMonad $ \sk fk st -> sk (st_inline_threshold st) fk st